unit ecxmlparser;
{$IFDEF FPC}
{$H+}
{$ENDIF}

interface

uses
{$IFDEF FPC}
  LResources,
{$ENDIF}  
  Classes, SysUtils,
  ecxmlsaxtokenizer,
  XMLSupport;

type
  TXMLItem = class;
  TXMLContainerNode = class;

  TXMLItemType = (itText, itCData, itComment, itContainer, itHeader);
  TXMLWarning  = procedure(const ABaseMessage, APreview : string; const AtLine, AtLinePos : Integer; var XMLContainer : TXMLContainerNode; var Handled : Boolean) of object;

  { TXMLItem }

  TXMLItem = class
  private
    FLineNo: LongInt;
    FLinePos: LongInt;
    FParent : TXMLContainerNode;
    function GetAsString: AnsiString;
    function GetItemType: TXMLItemType;
    procedure SetAsString(const AValue: AnsiString);
  public
    constructor Create(AParent: TXMLContainerNode = nil); virtual;
    destructor Destroy; override;
    
    property ItemType : TXMLItemType read GetItemType;
    property Parent : TXMLContainerNode read FParent;
    property LineNo : LongInt read FLineNo;
    property LinePos: LongInt read FLinePos;
    property AsString : AnsiString read GetAsString write SetAsString;
  end;

  { TXMLContainerNode }

  TXMLContainerNode = class(TXMLItem)
  private
    FName: AnsiString;
    FSubItems : TList;
    FParams : TXMLParamList;
    function GetParams: TXMLParamList;
    function GetSubItemCount: Integer;
    function GetSubItems(index : integer): TXMLItem;
    function GetChildContainers(index: string): TXMLContainerNode;
    procedure SetName(const AValue: AnsiString);
    procedure SetParams(const AValue: TXMLParamList);
    function GetText:widestring;
    procedure Settext(s:widestring);
  public
    constructor Create(AParent: TXMLContainerNode = nil); override;
    destructor Destroy; override;

    procedure Clear;
    function  New(AnItemType : TXMLItemType) : TXMLItem; // Create a new child
    function NewContainer(n:string):TXMLCOntainerNode;
    procedure Delete(Index : Integer); // Free and remove
    procedure Remove(Item : TXMLItem); // Remove from list, but don't free
    function  Insert(Item : TXMLItem; Index : Integer = -1) : Integer; // Insert child into list
    function  IndexOf(Item : TXMLItem) : Integer;
    function hasattribute(attr:string):boolean;
    function GetAttributes_float(index:string;default:double=0):double;
    function GetAttributes_int(index:string;default:integer=0):integer;

    function GetAttributes(index:string;default:string=''):string;
    function GetAttributes_ws(index:string;default:widestring=''):widestring;

    procedure SetAttributes_float(index:string;value:double);
    procedure SetAttributes_int(index:string;value:int64);
    procedure SetAttributes(index:string;value:string);
    procedure SetAttributes_ws(index:string;value:widestring);


    property SubItems[index : integer] : TXMLItem read GetSubItems;
    property childcontainers[index:string] : TXMLContainerNode read GetChildContainers;
    property SubItemCount : Integer read GetSubItemCount;
    property Name : AnsiString read FName write SetName;
    property Params : TXMLParamList read GetParams write SetParams;
    property text:widestring read GetText write Settext;
  end;

  { TXMLHeader }

  TXMLHeaderItem = class(TXMLItem)
  private
    FHeader: AnsiString;
    FParams : TXMLParamList;
    function GetParams: TXMLParamList;
    procedure SetHeader(const AValue: AnsiString);
    procedure SetParams(const AValue: TXMLParamList);
  public
    constructor Create(AParent: TXMLContainerNode = nil); override;
    destructor Destroy; override;
    
    property Header : AnsiString read FHeader write SetHeader;
    property Params : TXMLParamList read GetParams write SetParams;
  end;

  { TXMLTextItem }

  TXMLTextItem = class(TXMLItem)
  private
    FText: wideString;
    procedure SetText(const AValue: wideString);
  public
    property Text : wideString read FText write SetText;
  end;

  { TXMLCDataItem }

  TXMLCDataItem = class(TXMLItem)
  private
    FText: AnsiString;
    procedure SetText(const AValue: AnsiString);
  public
    property CData : AnsiString read FText write SetText;
  end;

  { TXMLCommentItem }

  TXMLCommentItem = class(TXMLItem)
  private
    FText: AnsiString;
    procedure SetText(const AValue: AnsiString);
  public
    property Comment : AnsiString read FText write SetText;
  end;

  { TXMLParser }

  TXMLParser = class(TComponent)
  private
    FOnException: TXMLException;
    FOnWarning: TXMLWarning;
    FWorkingNode,
    FHeaders,
    FRoot: TXMLContainerNode;

    function GetHeaderCount: Integer;
    function GetHeaders(index: integer): TXMLHeaderItem;
    
    procedure OnXMLHeader           (Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLStartElement     (Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLEndElement       (Sender: TObject; Symbol : AnsiString);
    procedure OnXMLStandAloneElement(Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLComment          (Sender: TObject; Contents : AnsiString);
    procedure OnXMLCData            (Sender: TObject; Contents : AnsiString);
    procedure OnXMLText             (Sender: TObject; Contents : AnsiString);
    
    procedure DoException(const ABaseMessage, APreview : string; const AtLine, AtLinePos : Integer; var Handled : Boolean);
    function  DoWarning(Tokenizer : TXMLTokenizer; const ABaseMessage:String) : Boolean;
    
    procedure SetOnException(const AValue: TXMLException);
    procedure SetOnWarning(const AValue: TXMLWarning);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure LoadFromStrings(Source : TStrings);
    procedure LoadFromStream(Source : TStream);
    procedure LoadFromFile(FileName : AnsiString);
    
    procedure SaveToStrings(Dest : TStrings);
    procedure SaveToStream(Dest : TStream);
    procedure SaveToFile(FileName : AnsiString);

    function  NewHeader : TXMLHeaderItem;
    procedure DeleteHeader(Index : Integer);
    procedure ClearHeaders;
    procedure Clear;
    
    property Root : TXMLContainerNode read FRoot;
    property Headers[index:integer] : TXMLHeaderItem read GetHeaders;
    property HeaderCount : Integer read GetHeaderCount;
  published
    property OnException : TXMLException read FOnException write SetOnException;
    property OnWarning   : TXMLWarning read FOnWarning write SetOnWarning;
  end;

  { TXMLSAXParser }

  TXMLSAXParser = class(TComponent)
  private
    FSAXTokenizer : TXMLTokenizer;
    function GetIsEOF: Boolean;
    function GetLineStartNumber: LongInt;
    function GetLineStartPos: LongInt;
    function GetOnCData: TXMLCData;
    function GetOnComment: TXMLComment;
    function GetOnEndElement: TXMLEndElement;
    function GetOnException: TXMLException;
    function GetOnHeader: TXMLHeader;
    function GetOnStandAloneElement: TXMLStandAloneElement;
    function GetOnStartElement: TXMLStartElement;
    function GetOnText: TXMLText;
    function GetPosition: LongInt;
    function GetSource: PChar;
    function GetToken: Char;
    function GetTokenLength: LongInt;
    function GetTokenStart: LongInt;
    function GetTokenText: AnsiString;
    procedure SetOnCData(const AValue: TXMLCData);
    procedure SetOnComment(const AValue: TXMLComment);
    procedure SetOnEndElement(const AValue: TXMLEndElement);
    procedure SetOnException(const AValue: TXMLException);
    procedure SetOnHeader(const AValue: TXMLHeader);
    procedure SetOnStandAloneElement(const AValue: TXMLStandAloneElement);
    procedure SetOnStartElement(const AValue: TXMLStartElement);
    procedure SetOnText(const AValue: TXMLText);
    procedure SetSource(const AValue: PChar);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Reset;
    procedure Start;
    procedure Stop;
    function  NextToken : Char;

    procedure Error(const Ident: AnsiString);
    procedure ErrorFmt(const Message: AnsiString; const Args: array of const);

    procedure Throw(ErrorMessage : String);

    property LineNumber : LongInt read GetLineStartNumber;
    property LinePos    : LongInt read GetLineStartPos;
    property TokenLength: LongInt read GetTokenLength;
    property Position   : LongInt read GetPosition;
    property TokenStart : LongInt read GetTokenStart;

    property TokenText  : AnsiString read GetTokenText;
    property Token      : Char read GetToken;

    property EOF        : Boolean read GetIsEOF;

    property Source     : PChar read GetSource write SetSource;
  published
    property OnHeader            : TXMLHeader read GetOnHeader write SetOnHeader;
    property OnStartElement      : TXMLStartElement read GetOnStartElement write SetOnStartElement;
    property OnEndElement        : TXMLEndElement read GetOnEndElement write SetOnEndElement;
    property OnStandAloneElement : TXMLStandAloneElement read GetOnStandAloneElement write SetOnStandAloneElement;
    property OnComment           : TXMLComment read GetOnComment write SetOnComment;
    property OnCData             : TXMLCData read GetOnCData write SetOnCData;
    property OnText              : TXMLText read GetOnText write SetOnText;

    property OnException         : TXMLException read GetOnException write SetOnException;
  end;

  { TXMLLoader }

  TXMLLoader = class
  private
    FRoot,
    FWorkingNode: TXMLContainerNode;
    FOnException: TXMLException;
    FOnWarning: TXMLWarning;
    FSource: PChar;
    procedure SetOnException(const AValue: TXMLException);
    procedure SetOnWarning(const AValue: TXMLWarning);
    procedure SetSource(const AValue: PChar);

    procedure OnXMLHeader           (Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLStartElement     (Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLEndElement       (Sender: TObject; Symbol : AnsiString);
    procedure OnXMLStandAloneElement(Sender: TObject; Symbol : AnsiString; Params : TXMLParamList);
    procedure OnXMLComment          (Sender: TObject; Contents : AnsiString);
    procedure OnXMLCData            (Sender: TObject; Contents : AnsiString);
    procedure OnXMLText             (Sender: TObject; Contents : AnsiString);

    procedure DoException(const ABaseMessage, APreview : string; const AtLine, AtLinePos : Integer; var Handled : Boolean);
    function  DoWarning(Tokenizer : TXMLTokenizer; const ABaseMessage:String) : Boolean;
  public
    function Load(TargetNode : TXMLItem) : TXMLContainerNode;

    property Source : PChar read FSource write SetSource;

    property OnException : TXMLException read FOnException write SetOnException;
    property OnWarning   : TXMLWarning read FOnWarning write SetOnWarning;
  end;

function XMLItemToXMLString(AnItem : TXMLItem; Level : Integer = 0; IndentBy : Integer = 2) : AnsiString;
procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Eon Clash', [TXMLParser, TXMLSAXParser]);
end;

// This is a recursive method and may blow the stack on large XML files,
// in the end I need to replace this with a stack based approach.
function XMLItemToXMLString(AnItem : TXMLItem; Level : Integer = 0; IndentBy : Integer = 2) : AnsiString;
var
  pre : AnsiString;
  i : Integer;
  nestedcr:string;
  function FormatParams : String;
  var
    i : Integer;
  begin
    result := '';
    if AnItem is TXMLContainerNode then
      begin
        if TXMLContainerNode(AnItem).Params.Count > 0 then
          begin
            result := ' ';
            for i := 0 to TXMLContainerNode(AnItem).Params.Count -1 do
              result := result + format('%s="%s" ', [TXMLContainerNode(AnItem).Params.Names[i], TXMLContainerNode(AnItem).Params.Values[TXMLContainerNode(AnItem).Params.Names[i]]]);
            result := copy(result, 1, length(result)-1);
          end;
      end
    else
      if AnItem is TXMLHeaderItem then
        begin
          if TXMLHeaderItem(AnItem).Params.Count > 0 then
            begin
              result := ' ';
              for i := 0 to TXMLHeaderItem(AnItem).Params.Count -1 do
                result := result + format('%s="%s" ', [TXMLHeaderItem(AnItem).Params.Names[i], TXMLHeaderItem(AnItem).Params.Values[TXMLHeaderItem(AnItem).Params.Names[i]]]);
              result := copy(result, 1, length(result)-1);
            end;
        end;
  end;
begin
  result := '';
  pre := StringOfChar(#32, Level * IndentBy);
  case AnItem.ItemType of

    itText      : result := (utf8encode(TXMLTextItem(AnItem).Text));
    itCData     : result := (pre + '<![CDATA['+TXMLCDataItem(AnItem).CData+']]>') + #13#10;
    itComment   : result := (pre + '<!--'+TXMLCommentItem(AnItem).Comment+'-->') + #13#10;
    itHeader    : result := (pre + '<?'+TXMLHeaderItem(AnItem).Header+FormatParams + '?>') + #13#10;
    itContainer : begin
                    if TXMLContainerNode(AnItem).SubItemCount > 0 then
                      begin
                        nestedcr:=#13#10;
                        if (TXMLContainerNode(AnItem).SubItemCount=1) and
                          (TXMLContainerNode(AnItem).SubItems[0] is TXMLTextItem) then begin
                            nestedcr:='';
                            pre:='';
                        end;
                        result := (pre + '<' + TXMLContainerNode(AnItem).Name + FormatParams + '>') + nestedcr;
                        for i := 0 to TXMLContainerNode(AnItem).SubItemCount -1 do
                          result := result + XMLItemToXMLString(TXMLContainerNode(AnItem).SubItems[i], Level + 1);
                        result := result + (pre + '</' + TXMLContainerNode(AnItem).Name + '>') + #13#10;
                      end
                    else
                      result := (pre + '<' + TXMLContainerNode(AnItem).Name + FormatParams + '/>') + #13#10;
                  end;
  end;
end;

{ TXMLItem }

function TXMLItem.GetItemType: TXMLItemType;
begin
  if self is TXMLTextItem then
    result := itText
  else if self is TXMLContainerNode then
    result := itContainer
  else if self is TXMLCDataItem then
    result := itCData
  else if self is TXMLCommentItem then
    result := itComment
  else if self is TXMLHeaderItem then
    result := itHeader;
end;

procedure TXMLItem.SetAsString(const AValue: AnsiString);
var
  Loader : TXMLLoader;
begin
  Loader := TXMLLoader.Create;
  try
    Loader.Source := PChar(AValue);
    Loader.Load(Self);
  finally
    Loader.Free;
  end;
end;

function TXMLItem.GetAsString: AnsiString;
begin
  result := XMLItemToXMLString(self);
end;

constructor TXMLItem.Create(AParent: TXMLContainerNode);
begin
  FParent := AParent;
  FLineNo := -1;
  FLinePos:= -1;
end;

destructor TXMLItem.Destroy;
begin
  if Assigned(FParent) then
    FParent.Remove(Self);
  inherited Destroy;
end;

{ TXMLContainerNode }

function TXMLContainerNode.GetSubItemCount: Integer;
begin
  result := FSubItems.Count;
end;

function TXMLContainerNode.GetParams: TXMLParamList;
begin
  result := FParams;
end;

function TXMLContainerNode.GetSubItems(index : integer): TXMLItem;
begin
  result := TXMLItem(FSubItems[index]);
end;

procedure TXMLContainerNode.SetName(const AValue: AnsiString);
begin
  if FName=AValue then exit;
  FName:=AValue;
end;

procedure TXMLContainerNode.SetParams(const AValue: TXMLParamList);
begin
  FParams.Assign(AValue);
end;

constructor TXMLContainerNode.Create(AParent: TXMLContainerNode);
begin
  inherited Create(AParent);
  FSubItems := TList.Create;
  FParams := TXMLParamList.Create;
end;

destructor TXMLContainerNode.Destroy;
begin
  Clear;
  FSubItems.Free;
  FParams.Free;
  inherited Destroy;
end;

procedure TXMLContainerNode.Clear;
var
  x : TXMLItem;
begin
  while FSubItems.Count > 0 do
    begin
      x := TXMLItem(FSubItems[FSubItems.Count-1]);
      x.Free;
    end;
//  FParams.Clear;
//  FName := '';
end;

function TXMLContainerNode.New(AnItemType: TXMLItemType): TXMLItem;
begin
  case AnItemType of
    itText      : result := TXMLTextItem.Create(self);
    itCData     : result := TXMLCDataItem.Create(self);
    itComment   : result := TXMLCommentItem.Create(self);
    itContainer : result := TXMLContainerNode.Create(self);
    itHeader    : result := TXMLHeaderItem.Create(self);
  else
    result := nil;
  end;
  if result <> nil then
    FSubItems.Add(result);
end;

procedure TXMLContainerNode.Delete(Index: Integer);
var
  x : TXMLItem;
begin
  x := TXMLItem(FSubItems[Index]);
  x.Free;
end;

procedure TXMLContainerNode.Remove(Item: TXMLItem);
begin
  FSubItems.Remove(Item);
  Item.FParent := nil;
end;

function TXMLContainerNode.Insert(Item: TXMLItem; Index: Integer): Integer;
begin
  if Item.FParent <> nil then
    Item.FParent.Remove(Item);
  if Index > -1 then
    begin
      FSubItems.Insert(Index, Item);
      Result := FSubItems.IndexOf(Item);
    end
  else
    result := FSubItems.Add(Item);
  Item.FParent := self;
end;

function TXMLContainerNode.IndexOf(Item: TXMLItem): Integer;
begin
  result := FSubItems.IndexOf(Item);
end;

function TXMLContainerNode.GetChildContainers(
  index: string): TXMLContainerNode;
var
  node:TXMLItem;
  i:integer;
begin
  result:=nil;
  for i:=0 to SubItemCount-1 do begin
    node:=subitems[i];
    if not (node is TXMLContainerNode) then continue;
    if (node as TXMLContainerNOde).Name=index then begin
      result:=node as TXMLcontainerNode;
      exit;
    end;
  end;
end;
function TXMLContainerNode.GetAttributes(index: string; default:string=''):string;
begin
  result:=default;
  if not assigned(params) then exit;
  if params.IndexOfName(index)=-1 then exit;
  result:=params.Values[index];
end;
function TXMLContainerNode.GetAttributes_int(index: string; default:integer=0): integer;
begin
  result:=default;
  if not assigned(params) then exit;
  if params.IndexOfName(index)=-1 then exit;
  result:=strtointdef(params.Values[index],default);
end;
function TXMLContainerNode.GetAttributes_float(index: string;default:double=0): double;
begin
  result:=default;
  if not assigned(params) then exit;
  if params.IndexOfName(index)=-1 then exit;
  result:=strtofloatdef(params.Values[index],default);
end;
procedure TXMLContainerNode.SetAttributes(index: string; value:string);
begin
  if not assigned(params) then exit;
  params.Values[index]:=value;
end;
procedure TXMLContainerNode.SetAttributes_int(index: string; value:int64);
begin
  if not assigned(params) then exit;
  params.Values[index]:=inttostr(value);
end;
procedure TXMLContainerNode.SetAttributes_float(index: string;value:double);
begin
  if not assigned(params) then exit;
  params.Values[index]:=floattostr(value);
end;

function TXMLContainerNode.hasattribute(attr: string): boolean;
begin
  if not assigned(params) then exit;
  result:=params.IndexOfName(attr)>-1;
end;

function TXMLContainerNode.NewContainer(n:string): TXMLCOntainerNode;
begin
  result:=New(itcontainer) as TXMLContainerNode;
  result.Name:=n;
end;

function TXMLContainerNode.GetText: widestring;
begin
  result:='';
  if SubItemCount<>1 then exit;
  if SubItems[0].GetItemType <> itText then exit;
  result:=TXMLTextItem(subitems[0]).text;
end;

procedure TXMLContainerNode.Settext(s: widestring);
var
  ti:TXMLTextItem;
begin
  clear;
  ti:=new(itText) as TXMLTextItem;
  ti.Text:=s;
end;

function TXMLContainerNode.GetAttributes_ws(index: string;
  default: widestring): widestring;
begin
  result:=default;
  if not assigned(params) then exit;
  if hasattribute(index) then 
  result:=UTF8Decode(params.Values[index]);
end;

procedure TXMLContainerNode.SetAttributes_ws(index: string;
  value: widestring);
begin
  if not assigned(params) then exit;
  params.Values[index]:=UTF8Encode(value);
end;

{ TXMLParser }

procedure TXMLParser.OnXMLHeader(Sender: TObject; Symbol: AnsiString;
  Params: TXMLParamList);
var
  x : TXMLHeaderItem;
begin
  if FWorkingNode = nil then
    x := NewHeader
  else
    x := TXMLHeaderItem(FWorkingNode.New(itHeader));
  x.Header := symbol;
  x.Params := Params;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

function TXMLParser.GetHeaderCount: Integer;
begin
  result := FHeaders.SubItemCount;
end;

function TXMLParser.GetHeaders(index: integer): TXMLHeaderItem;
begin
  result := TXMLHeaderItem(FHeaders.SubItems[index]);
end;

procedure TXMLParser.OnXMLStartElement(Sender: TObject; Symbol: AnsiString;
  Params: TXMLParamList);
begin
  if FWorkingNode = nil then
    FWorkingNode := FRoot
  else
    FWorkingNode := TXMLContainerNode(FWorkingNode.New(itContainer));
  FWorkingNode.Name := Symbol;
  FWorkingNode.Params := Params;
  FWorkingNode.FLineNo := TXMLTokenizer(Sender).LineNumber;
  FWorkingNode.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLParser.OnXMLEndElement(Sender: TObject; Symbol: AnsiString);
begin
  if (FWorkingNode <> nil) and (FWorkingNode.Parent <> nil) then
    begin
      if (XMLCompareStr(FWorkingNode.Name, Symbol)) then
        FWorkingNode := TXMLContainerNode(FWorkingNode.Parent)
      else
        if not DoWarning(TXMLTokenizer(Sender), 'Closing tag for ' + FWorkingNode.Name +
                         '('+format('Line: %d Pos: %d', [FWorkingNode.LineNo, FWorkingNode.LinePos])+
                         ') expected but closing tag of ' + Symbol + '('+
                         format('Line: %d Pos: %d', [TXMLTokenizer(Sender).LineNumber, TXMLTokenizer(Sender).LinePos])+
                         ') found.') then
          while (not XMLCompareStr(FWorkingNode.Name, Symbol)) and
                (FWorkingNode.Parent <> nil) do
            FWorkingNode := TXMLContainerNode(FWorkingNode.Parent);
    end;
end;

procedure TXMLParser.OnXMLStandAloneElement(Sender: TObject;
  Symbol: AnsiString; Params: TXMLParamList);
var
  x : TXMLContainerNode;
begin
  if FWorkingNode = nil then
    x := FRoot
  else
    x := TXMLContainerNode(FWorkingNode.New(itContainer));
  x.Name := Symbol;
  x.Params := Params;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLParser.OnXMLComment(Sender: TObject; Contents: AnsiString);
var
  x : TXMLCommentItem;
begin
  if FWorkingNode = nil then
    x := TXMLCommentItem(FRoot.New(itComment))
  else
    x := TXMLCommentItem(FWorkingNode.New(itComment));
  x.Comment := Contents;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLParser.OnXMLCData(Sender: TObject; Contents: AnsiString);
var
  x : TXMLCDataItem;
begin
  if FWorkingNode = nil then
    x := TXMLCDataItem(FRoot.New(itCData))
  else
    x := TXMLCDataItem(FWorkingNode.New(itCData));
  x.CData := Contents;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLParser.OnXMLText(Sender: TObject; Contents: AnsiString);
var
  x : TXMLTextItem;
begin
  if FWorkingNode = nil then
    x := TXMLTextItem(FRoot.New(itText))
  else
    x := TXMLTextItem(FWorkingNode.New(itText));
  x.Text := Utf8Decode(Contents);
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLParser.DoException(const ABaseMessage, APreview: string;
  const AtLine, AtLinePos: Integer; var Handled: Boolean);
begin
  if Assigned(FOnException) then
    FOnException(ABaseMessage, APreview, AtLine, AtLinePos, Handled);
end;

function TXMLParser.DoWarning(Tokenizer : TXMLTokenizer; const ABaseMessage:String) : Boolean;
var
  preview : String;
begin
  preview := '';
  if Tokenizer.Position-Tokenizer.TokenStart > 100 then
    SetString(preview, Tokenizer.Source+Tokenizer.TokenStart, 100)
  else
    SetString(preview, Tokenizer.Source+Tokenizer.TokenStart, Tokenizer.Position-Tokenizer.TokenStart);

  Result := false;

  if Assigned(FOnWarning) then
    FOnWarning(ABaseMessage, Preview, Tokenizer.LineNumber, Tokenizer.LinePos, FWorkingNode, Result);

  if not Result then
    raise TXMLTokenizerException.Create(etWarning, ABaseMessage, Preview, Tokenizer.LineNumber, Tokenizer.LinePos);
end;

procedure TXMLParser.SetOnException(const AValue: TXMLException);
begin
//  if FOnException=AValue then exit;
  FOnException:=AValue;
end;

procedure TXMLParser.SetOnWarning(const AValue: TXMLWarning);
begin
//  if FOnWarning=AValue then exit;
  FOnWarning:=AValue;
end;

constructor TXMLParser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRoot := TXMLContainerNode.Create(nil);
  FHeaders := TXMLContainerNode.Create(nil);
end;

destructor TXMLParser.Destroy;
begin
  FRoot.Free;
  FHeaders.Free;
  inherited Destroy;
end;

procedure TXMLParser.LoadFromStrings(Source: TStrings);
var
  ms : TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    Source.SaveToStream(ms);
    ms.Position := 0;
    LoadFromStream(ms);
  finally
    ms.Free;
  end;
end;

procedure TXMLParser.LoadFromStream(Source: TStream);
var
  ms    : TMemoryStream;
  tknizr: TXMLTokenizer;
  spos  : Int64;
  b     : Char;
  wrote : Boolean;
begin
  FRoot.Clear;
  FHeaders.Clear;
  FWorkingNode := nil;
  if Source is TMemoryStream then
    ms := TMemoryStream(Source)
  else
    begin
      ms := TMemoryStream.Create;
      ms.CopyFrom(Source, Source.Size - Source.Position);
    end;
  try
    tknizr:= TXMLTokenizer.Create;
    try
      tknizr.OnHeader            := OnXMLHeader;
      tknizr.OnStartElement      := OnXMLStartElement;
      tknizr.OnEndElement        := OnXMLEndElement;
      tknizr.OnStandAloneElement := OnXMLStandAloneElement;
      tknizr.OnComment           := OnXMLComment;
      tknizr.OnCData             := OnXMLCData;
      tknizr.OnText              := OnXMLText;

      spos := ms.Position;
      ms.Position := ms.Size-1;
      b := #0;
      ms.Read(b, 1);
      wrote := b <> #0; // Make sure that the stream is null terminated
      if wrote then
        begin
          b := #0;
          ms.Write(b, 1);
        end;
      ms.Position := spos;

      tknizr.Source := ms.Memory;
      while not tknizr.EOF do
        tknizr.NextToken;
      if wrote and (Source is TMemoryStream) then // if it wasn't and its not a copy return it to the origional form
        ms.Size := ms.Size -1;
    finally
      tknizr.Free;
    end;
  finally
    if not(Source is TMemoryStream) then
      ms.Free;
  end;
end;

procedure TXMLParser.LoadFromFile(FileName: AnsiString);
var
  fs : TFileStream;
begin
  fs := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(fs);
  finally
    fs.Free;
  end;
end;

procedure TXMLParser.SaveToStrings(Dest: TStrings);
var
  c : Integer;
begin
  Dest.Clear;
  for c := 0 to HeaderCount -1 do
    Dest.Text := Dest.Text + Headers[c].AsString;
  Dest.Text := Dest.Text + Root.AsString;
end;

procedure TXMLParser.SaveToStream(Dest: TStream);
var
  s : AnsiString;
  c : Integer;
begin
  s := '';
  for c := 0 to HeaderCount -1 do
    s := s + Headers[c].AsString;
  s := s + Root.AsString;
  Dest.Write(s[1], Length(s));
end;

procedure TXMLParser.SaveToFile(FileName: AnsiString);
var
  fs : TFileStream;
begin
  fs := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(fs);
  finally
    fs.Free;
  end;
end;

function TXMLParser.NewHeader: TXMLHeaderItem;
begin
  result := TXMLHeaderItem(FHeaders.New(itHeader));
end;

procedure TXMLParser.DeleteHeader(Index: Integer);
begin
  if FHeaders.SubItemCount > Index then
    FHeaders.Delete(Index);
end;

procedure TXMLParser.ClearHeaders;
begin
  FHeaders.Clear;
end;

procedure TXMLParser.Clear;
begin
  ClearHeaders;
  FRoot.Clear;
end;

{ TXMLCDataItem }

procedure TXMLCDataItem.SetText(const AValue: AnsiString);
begin
  if FText=AValue then exit;
  FText:=AValue;
end;

{ TXMLTextItem }

procedure TXMLTextItem.SetText(const AValue: WideString);
begin
  if FText=AValue then exit;
  FText:=AValue;
end;

{ TXMLCommentItem }

procedure TXMLCommentItem.SetText(const AValue: AnsiString);
begin
  if FText=AValue then exit;
  FText:=AValue;
end;

{ TXMLHeaderItem }

function TXMLHeaderItem.GetParams: TXMLParamList;
begin
  result := FParams;
end;

procedure TXMLHeaderItem.SetHeader(const AValue: AnsiString);
begin
  if FHeader=AValue then exit;
  FHeader:=AValue;
end;

procedure TXMLHeaderItem.SetParams(const AValue: TXMLParamList);
begin
  FParams.Assign(AValue);
end;

constructor TXMLHeaderItem.Create(AParent: TXMLContainerNode);
begin
  inherited Create(AParent);
  FParams := TXMLParamList.Create;
end;

destructor TXMLHeaderItem.Destroy;
begin
  FParams.Free;
  inherited Destroy;
end;

{ TXMLLoader }

procedure TXMLLoader.SetOnException(const AValue: TXMLException);
begin
//  if FOnException=AValue then exit;
  FOnException:=AValue;
end;

procedure TXMLLoader.SetOnWarning(const AValue: TXMLWarning);
begin
//  if FOnWarning=AValue then exit;
  FOnWarning:=AValue;
end;

procedure TXMLLoader.SetSource(const AValue: PChar);
begin
  if FSource=AValue then exit;
  FSource:=AValue;
end;

procedure TXMLLoader.OnXMLHeader(Sender: TObject; Symbol: AnsiString;
  Params: TXMLParamList);
var
  x : TXMLHeaderItem;
begin
  if FWorkingNode = nil then
    exit;
  x := TXMLHeaderItem(FWorkingNode.New(itHeader));
  x.Header := symbol;
  x.Params := Params;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.OnXMLStartElement(Sender: TObject; Symbol: AnsiString;
  Params: TXMLParamList);
begin
  if FWorkingNode = nil then
    FWorkingNode := FRoot
  else
    FWorkingNode := TXMLContainerNode(FWorkingNode.New(itContainer));
  FWorkingNode.Name := Symbol;
  FWorkingNode.Params := Params;
  FWorkingNode.FLineNo := TXMLTokenizer(Sender).LineNumber;
  FWorkingNode.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.OnXMLEndElement(Sender: TObject; Symbol: AnsiString);
begin
  if (FWorkingNode <> nil) and (FWorkingNode.Parent <> nil) then
    begin
      if (XMLCompareStr(FWorkingNode.Name, Symbol)) then
        FWorkingNode := TXMLContainerNode(FWorkingNode.Parent)
      else
        if not DoWarning(TXMLTokenizer(Sender), 'Closing tag for ' + FWorkingNode.Name +
                         '('+format('Line: %d Pos: %d', [FWorkingNode.LineNo, FWorkingNode.LinePos])+
                         ') expected but closing tag of ' + Symbol + '('+
                         format('Line: %d Pos: %d', [TXMLTokenizer(Sender).LineNumber, TXMLTokenizer(Sender).LinePos])+
                         ') found.') then
          while (not XMLCompareStr(FWorkingNode.Name, Symbol)) and
                (FWorkingNode.Parent <> nil) do
            FWorkingNode := TXMLContainerNode(FWorkingNode.Parent);
    end;
end;

procedure TXMLLoader.OnXMLStandAloneElement(Sender: TObject;
  Symbol: AnsiString; Params: TXMLParamList);
var
  x : TXMLContainerNode;
begin
  if FWorkingNode = nil then
    x := FRoot
  else
    x := TXMLContainerNode(FWorkingNode.New(itContainer));
  x.Name := Symbol;
  x.Params := Params;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.OnXMLComment(Sender: TObject; Contents: AnsiString);
var
  x : TXMLCommentItem;
begin
  if FWorkingNode = nil then
    x := TXMLCommentItem(FRoot.New(itComment))
  else
    x := TXMLCommentItem(FWorkingNode.New(itComment));
  x.Comment := Contents;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.OnXMLCData(Sender: TObject; Contents: AnsiString);
var
  x : TXMLCDataItem;
begin
  if FWorkingNode = nil then
    x := TXMLCDataItem(FRoot.New(itCData))
  else
    x := TXMLCDataItem(FWorkingNode.New(itCData));
  x.CData := Contents;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.OnXMLText(Sender: TObject; Contents: AnsiString);
var
  x : TXMLTextItem;
begin
  if FWorkingNode = nil then
    x := TXMLTextItem(FRoot.New(itText))
  else
    x := TXMLTextItem(FWorkingNode.New(itText));
  x.Text := Contents;
  x.FLineNo := TXMLTokenizer(Sender).LineNumber;
  x.FLinePos:= TXMLTokenizer(Sender).LinePos;
end;

procedure TXMLLoader.DoException(const ABaseMessage, APreview: string;
  const AtLine, AtLinePos: Integer; var Handled: Boolean);
begin
  if Assigned(FOnException) then
    FOnException(ABaseMessage, APreview, AtLine, AtLinePos, Handled);
end;

function TXMLLoader.DoWarning(Tokenizer: TXMLTokenizer;
  const ABaseMessage: String): Boolean;
var
  preview : AnsiString;
begin
  preview := '';
  if Tokenizer.Position-Tokenizer.TokenStart > 100 then
    SetString(preview, Tokenizer.Source+Tokenizer.TokenStart, 100)
  else
    SetString(preview, Tokenizer.Source+Tokenizer.TokenStart, Tokenizer.Position-Tokenizer.TokenStart);

  Result := false;

  if Assigned(FOnWarning) then
    FOnWarning(ABaseMessage, Preview, Tokenizer.LineNumber, Tokenizer.LinePos, FWorkingNode, Result);

  if not Result then
    raise TXMLTokenizerException.Create(etWarning, ABaseMessage, Preview, Tokenizer.LineNumber, Tokenizer.LinePos);
end;

function TXMLLoader.Load(TargetNode: TXMLItem) : TXMLContainerNode;
var
  xItem : TXMLContainerNode;
  tknizr: TXMLTokenizer;
  ReplaceTarget : Boolean;
begin
  ReplaceTarget := (TargetNode = nil) or (not (TargetNode is TXMLContainerNode));
  if ReplaceTarget then
    FRoot := TXMLContainerNode.Create
  else
    FRoot := TXMLContainerNode(TargetNode);

  FWorkingNode:=nil;

  tknizr:= TXMLTokenizer.Create;
  try
    tknizr.OnHeader            := OnXMLHeader;
    tknizr.OnStartElement      := OnXMLStartElement;
    tknizr.OnEndElement        := OnXMLEndElement;
    tknizr.OnStandAloneElement := OnXMLStandAloneElement;
    tknizr.OnComment           := OnXMLComment;
    tknizr.OnCData             := OnXMLCData;
    tknizr.OnText              := OnXMLText;

    tknizr.Source := Source;
    while not tknizr.EOF do
      tknizr.NextToken;
  finally
    tknizr.Free;
  end;
  
  if ReplaceTarget then
    begin
      if Assigned(TargetNode.FParent) then
        begin
          xItem := TargetNode.FParent;
          //TargetNode.FParent := nil;
          xItem.FSubItems[xItem.IndexOf(TargetNode)] := FRoot;
          FRoot.FParent := xItem;
          TargetNode.FParent := nil;
          //xItem.Remove(TargetNode);
          //TargetNode.FParent.FSubItems[FWorkingNode.FParent.FSubItems.IndexOf(TargetNode)] := FRoot;
          TargetNode.Free;
        end;
    end;
  result := FRoot;
end;

{ TXMLSAXParser }

function TXMLSAXParser.GetIsEOF: Boolean;
begin
  result := FSAXTokenizer.EOF;
end;

function TXMLSAXParser.GetLineStartNumber: LongInt;
begin
  result := FSAXTokenizer.LineNumber;
end;

function TXMLSAXParser.GetLineStartPos: LongInt;
begin
  result := FSAXTokenizer.LinePos;
end;

function TXMLSAXParser.GetOnCData: TXMLCData;
begin
  result := FSAXTokenizer.OnCData;
end;

function TXMLSAXParser.GetOnComment: TXMLComment;
begin
  result := FSAXTokenizer.OnComment;
end;

function TXMLSAXParser.GetOnEndElement: TXMLEndElement;
begin
  result := FSAXTokenizer.OnEndElement;
end;

function TXMLSAXParser.GetOnException: TXMLException;
begin
  result := FSAXTokenizer.OnException;
end;

function TXMLSAXParser.GetOnHeader: TXMLHeader;
begin
  result := FSAXTokenizer.OnHeader;
end;

function TXMLSAXParser.GetOnStandAloneElement: TXMLStandAloneElement;
begin
  result := FSAXTokenizer.OnStandAloneElement;
end;

function TXMLSAXParser.GetOnStartElement: TXMLStartElement;
begin
  result := FSAXTokenizer.OnStartElement;
end;

function TXMLSAXParser.GetOnText: TXMLText;
begin
  result := FSAXTokenizer.OnText;
end;

function TXMLSAXParser.GetPosition: LongInt;
begin
  result := FSAXTokenizer.Position;
end;

function TXMLSAXParser.GetSource: PChar;
begin
  result := FSAXTokenizer.Source;
end;

function TXMLSAXParser.GetToken: Char;
begin
  result := FSAXTokenizer.Token;
end;

function TXMLSAXParser.GetTokenLength: LongInt;
begin
  result := FSAXTokenizer.TokenLength;
end;

function TXMLSAXParser.GetTokenStart: LongInt;
begin
  result := FSAXTokenizer.TokenStart;
end;

function TXMLSAXParser.GetTokenText: AnsiString;
begin
  result := FSAXTokenizer.TokenText;
end;

procedure TXMLSAXParser.SetOnCData(const AValue: TXMLCData);
begin
  FSAXTokenizer.OnCData := AValue;
end;

procedure TXMLSAXParser.SetOnComment(const AValue: TXMLComment);
begin
  FSAXTokenizer.OnComment := AValue;
end;

procedure TXMLSAXParser.SetOnEndElement(const AValue: TXMLEndElement);
begin
  FSAXTokenizer.OnEndElement := AValue;
end;

procedure TXMLSAXParser.SetOnException(const AValue: TXMLException);
begin
  FSAXTokenizer.OnException := AValue;
end;

procedure TXMLSAXParser.SetOnHeader(const AValue: TXMLHeader);
begin
  FSAXTokenizer.OnHeader := AValue;
end;

procedure TXMLSAXParser.SetOnStandAloneElement(
  const AValue: TXMLStandAloneElement);
begin
  FSAXTokenizer.OnStandAloneElement := AValue;
end;

procedure TXMLSAXParser.SetOnStartElement(const AValue: TXMLStartElement);
begin
  FSAXTokenizer.OnStartElement := AValue;
end;

procedure TXMLSAXParser.SetOnText(const AValue: TXMLText);
begin
  FSAXTokenizer.OnText := AValue;
end;

procedure TXMLSAXParser.SetSource(const AValue: PChar);
begin
  FSAXTokenizer.Source := AValue;
end;

constructor TXMLSAXParser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSAXTokenizer := TXMLTokenizer.Create;
end;

destructor TXMLSAXParser.Destroy;
begin
  if Assigned(FSAXTokenizer) then
    FSAXTokenizer.Free;
  inherited Destroy;
end;

procedure TXMLSAXParser.Reset;
begin
  FSAXTokenizer.Reset;
end;

procedure TXMLSAXParser.Start;
begin
  FSAXTokenizer.Start;
end;

procedure TXMLSAXParser.Stop;
begin
  FSAXTokenizer.Stop;
end;

function TXMLSAXParser.NextToken: Char;
begin
  result := FSAXTokenizer.NextToken;
end;

procedure TXMLSAXParser.Error(const Ident: AnsiString);
begin
  FSAXTokenizer.Error(Ident);
end;

procedure TXMLSAXParser.ErrorFmt(const Message: AnsiString;
  const Args: array of const);
begin
  FSAXTokenizer.ErrorFmt(Message, Args);
end;

procedure TXMLSAXParser.Throw(ErrorMessage: String);
begin
  FSAXTokenizer.Throw(ErrorMessage);
end;

initialization
{ $i xmlpi.lrs}
finalization
end.
